home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 015 / tinylst.arc / TL.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-07-04  |  4.8 KB  |  228 lines
  1. const
  2.   lines=300;     {This is number of lines per page.}
  3.   initstring=#27'3'#15#27'S0'#15;   {This is the printer init string.  It
  4.                                      sets Superscript, 15/216 inch line
  5.                                      spacing, and compressed print.  Change
  6.                                      this string for non Epson compatible
  7.                                      printers.}
  8.  
  9.  
  10.  
  11. type
  12.   chararray=array[1..2000] of char;
  13.   linetype=string[66];
  14.   pagetype=array[1..lines] of linetype;
  15.  
  16. var
  17.   page:pagetype;
  18.   block:chararray;
  19.   fil:text;
  20.   reform,new:boolean;
  21.   stop,maxlines:integer;
  22.   inname:linetype;
  23.  
  24. procedure readabunch;
  25.   var
  26.     i:integer;
  27.   begin
  28.     i:=1;
  29.     if not new then
  30.       for i:=1 to 100 do
  31.         block[i]:=block[1900+i];
  32.     repeat
  33.       read(fil,block[i]);
  34.       if block[i]<>#10 then
  35.         i:=succ(i);
  36.     until (i=2000) or eof(fil);
  37.     stop:=1900;
  38.     if i<1900 then
  39.       stop:=i;
  40.     if eof(fil) then block[i]:=#26;
  41.   end;
  42.  
  43. function countleft(s:integer):integer;
  44.   var
  45.     i:integer;
  46.   begin
  47.     i:=0;
  48.     while block[i+s]=' ' do
  49.       i:=succ(i);
  50.     countleft:=i;
  51.   end;
  52.  
  53. function pad(s:linetype):linetype;
  54.   var
  55.     s1:linetype;
  56.   begin
  57.     s1:=s;
  58.     while length(s1)<66 do
  59.       s1:=s1+' ';
  60.     pad:=s1;
  61.   end;
  62.  
  63. procedure printpage;
  64.   var
  65.     i:integer;
  66.   begin
  67.     i:=1;
  68.     while (i<=maxlines) and (i<=(lines div 2)) do
  69.       begin
  70.         write(lst,pad(page[i]));
  71.         if i+(lines div 2)<=maxlines then
  72.           write(lst,pad(page[i+(lines div 2)]));
  73.         i:=succ(i);
  74.         writeln(lst);
  75.       end;
  76.     writeln(lst,#12#10#10#10);
  77.   end;
  78.  
  79. procedure scrollline;
  80.   begin
  81.     if maxlines=lines then
  82.       begin
  83.         printpage;
  84.         maxlines:=1;
  85.       end
  86.     else
  87.       begin
  88.         maxlines:=succ(maxlines);
  89.         page[maxlines]:='';
  90.       end;
  91.   end;
  92.  
  93. procedure displaybunch;
  94.   var
  95.     i,j:integer;
  96.   const
  97.     lefmar:integer=0;
  98.   begin
  99.     for i:=1 to stop do
  100.       begin
  101.         if block[i]=#26 then
  102.           begin
  103.             printpage;
  104.             halt;
  105.           end;
  106.         if block[i]>#128 then
  107.           begin
  108.             textcolor(12);
  109.             writeln('|':66-wherex);
  110.             textcolor(14);
  111.             if lefmar>0 then
  112.               write(' ':lefmar);
  113.             scrollline;
  114.             if lefmar>0 then
  115.               for j:=1 to lefmar do
  116.                 page[maxlines]:=page[maxlines]+' ';
  117.             if block[i]<>#160 then
  118.               block[i]:=chr(ord(block[i])-128);
  119.           end;
  120.         if block[i]=#13 then
  121.           begin
  122.             writeln('«');
  123.             lefmar:=countleft(succ(i));
  124.             scrollline;
  125.           end;
  126.         if block[i] in [' '..'~'] then
  127.           begin
  128.             write(block[i]);
  129.             page[maxlines]:=page[maxlines]+block[i];
  130.           end;
  131.       end;
  132.   end;
  133.  
  134. procedure openfile;
  135.   var
  136.     c:char;
  137.   begin
  138.     write('Enter input file name: ');
  139.     readln(inname);
  140.     assign(fil,inname);
  141.     reset(fil);
  142.     writeln;
  143.     write('Reform paragraphs? ');
  144.     readln(c);
  145.     reform:=upcase(c)='Y';
  146.     writeln;
  147.   end;
  148.  
  149. procedure removecrs;
  150.   var
  151.     i,j,lm,lefmar:integer;
  152.   begin
  153.     i:=1;
  154.     if new then
  155.       lefmar:=countleft(i);
  156.     repeat
  157.       while block[i]<>#13 do
  158.         i:=succ(i);
  159.       lm:=countleft(succ(i));
  160.       if block[succ(i)]='' then
  161.         begin
  162.           reform:=not reform;
  163.           block[succ(i)]:=#0;
  164.           lm:=countleft(i+2);
  165.         end;
  166.       if (lm<=lefmar) and (block[succ(i)]<>#13) and (block[pred(i)]<>#13)
  167.                       and reform then
  168.         begin
  169.           block[i]:=' ';
  170.           if lm<>0 then
  171.             for j:=succ(i) to i+lm do
  172.               block[j]:=#0;
  173.         end;
  174.       lefmar:=lm;
  175.       i:=succ(i);
  176.     until (i>=stop);
  177.   end;
  178.  
  179. procedure insertlfs;
  180.   var
  181.     i,j,count,lefmar:integer;
  182.   const
  183.     leftovers:integer=1;
  184.   begin
  185.     i:=leftovers;
  186.     if new then
  187.       lefmar:=countleft(i);
  188.     new:=false;
  189.     repeat
  190.       count:=0;
  191.       if block[i]<>#13 then
  192.         count:=count+lefmar;
  193.       repeat
  194.         if block[i]<>#0 then count:=succ(count);
  195.         i:=succ(i);
  196.       until (count>63) or (block[i] in [#13,#26]);
  197.       case block[i] of
  198.         #13:lefmar:=countleft(succ(i));
  199.         #26:;
  200.         else
  201.           begin
  202.             while not (block[i] in [' ',#13,#128..#255]) do
  203.               i:=pred(i);
  204.             block[i]:=chr(ord(block[i])+128)
  205.           end
  206.       end;
  207.     until (i>stop) and (block[i] in [#13,#128..#255]);
  208.     leftovers:=i-stop;
  209.   end;
  210.  
  211. begin
  212.   writeln(lst,initstring);
  213.   new:=true;
  214.   clrscr;
  215.   openfile;
  216.   maxlines:=0;
  217.   scrollline;
  218.   repeat
  219.     readabunch;
  220.     removecrs;
  221.     insertlfs;
  222.     displaybunch;
  223.   until eof(fil);
  224.   close(fil);
  225. end.
  226.  
  227.  
  228.